home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / quasiquote.t < prev    next >
Text File  |  1988-02-05  |  5KB  |  142 lines
  1. (herald quasiquote)
  2.  
  3. ;;; Actual quasiquote stuff
  4.  
  5. (define-syntax (quasiquote x)
  6.   (expand-quasiquote x))
  7.  
  8. (define (unquote x)
  9.   (syntax-error "comma not inside backquote form~%  ,~s" x))
  10.  
  11. (define (unquote-splicing x)
  12.   (syntax-error "\",@\" not inside backquote form~%  ,@~s" x))
  13.  
  14. (define (expand-quasiquote x)
  15.   (receive (mode arg)
  16.            (descend-quasiquote x 0)
  17.     (finalize-quasiquote mode arg)))
  18.  
  19. (define quasiquote-marker 'quasiquote)
  20. (define unquote-marker    'unquote)
  21. (define splice-marker     'unquote-splicing)
  22.  
  23. (define (finalize-quasiquote mode arg)
  24.   (cond ((eq? mode 'quote) (list 'quote arg))
  25.         ((eq? mode 'unquote) arg)
  26.         ((eq? mode 'splice)
  27.          (error ",@~S in illegal context"
  28.                  arg))
  29.         ((fx<= (length arg) *maximum-number-of-arguments*)
  30.          (cons mode arg))
  31.         ((eq? mode 'append)
  32.          (build-quasiquote-list arg 'append 'append 'append))
  33.         (else 
  34.          (build-quasiquote-list arg 'list 'append! mode))))
  35.  
  36. (define (interesting-to-quasiquote? x marker)
  37.   (and (pair? x)
  38.        (eq? (car x) marker)
  39.        (pair? (cdr x))
  40.        (null? (cddr x))))
  41.  
  42. (define (build-quasiquote-list arg build join final)
  43.   (iterate loop ((args arg) (len (length arg)) (parts '()))
  44.     (cond ((fx<= len *maximum-number-of-arguments*)
  45.            (do ((ps parts (cdr ps))
  46.                 (rs (cons final args) (list join (car ps) rs)))
  47.                ((null? ps) rs)))
  48.           (else
  49.            (receive (part rest)
  50.                     (remove-front-elts args *maximum-number-of-arguments*)
  51.              (loop rest
  52.                    (fx- len *maximum-number-of-arguments*)
  53.                    (cons (cons build part) parts)))))))
  54.  
  55. (define (remove-front-elts l count)
  56.   (do ((l l (cdr l))
  57.        (e '() (cons (car l) e))
  58.        (i count (fx- i 1)))
  59.       ((fx<= i 0)
  60.        (return (reverse! e) l))))
  61.  
  62. ;; The continuation argument c is passed two values, mode and arg.
  63. ;; These are interpreted as follows:
  64. ;;    mode    arg          meaning
  65. ;;    QUOTE   x            'x
  66. ;;    UNQUOTE x            x
  67. ;;    LIST    (x1 x2 ...)  (LIST x1 x2 ...)
  68. ;;    CONS*   (x1 x2 ...)  (CONS* x1 x2 ...)
  69. ;;    APPEND  (x1 x2 ...)  (APPEND x1 x2 ...)
  70.  
  71. (define (descend-quasiquote x level)
  72.   (cond ((vector? x)
  73.          (descend-quasiquote-vector x level))
  74.         ((not (pair? x))
  75.          (return 'quote x))
  76.         ((interesting-to-quasiquote? x quasiquote-marker)
  77.          (descend-quasiquote-pair x (1+ level)))
  78.         ((interesting-to-quasiquote? x unquote-marker)
  79.          (cond ((= level 0)
  80.                 (return 'unquote (cadr x)))
  81.                (else
  82.                 (descend-quasiquote-pair x (- level 1)))))
  83.         ((interesting-to-quasiquote? x splice-marker)
  84.          (cond ((= level 0)
  85.                 (return 'splice (cadr x)))
  86.                (else
  87.                 (descend-quasiquote-pair x (- level 1)))))
  88.         (else
  89.          (descend-quasiquote-pair x level))))
  90.  
  91. ;; It would be simple to make this generate only a correct expansion;
  92. ;; most of the complexity here is in order to generate an
  93. ;; "optimized" expansion.
  94.  
  95. (define (descend-quasiquote-pair x level)
  96.   (receive (car-mode car-arg)
  97.            (descend-quasiquote (car x) level)
  98.     (receive (cdr-mode cdr-arg)
  99.              (descend-quasiquote (cdr x) level)
  100.       (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
  101.              (return 'quote x))
  102.             ((eq? car-mode 'splice)
  103.              (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
  104.                     (return 'unquote
  105.                             car-arg))
  106.                    ((eq? cdr-mode 'append)
  107.                     (return 'append
  108.                             (cons car-arg cdr-arg)))
  109.                    (else
  110.                     (return 'append
  111.                             (list car-arg
  112.                                   (finalize-quasiquote cdr-mode cdr-arg))))))
  113.             ((and (eq? cdr-mode 'quote) (null? cdr-arg))
  114.              (return 'list
  115.                      (list (finalize-quasiquote car-mode car-arg))))
  116.             ((or (eq? cdr-mode 'list) (eq? cdr-mode 'cons*))
  117.              (return cdr-mode
  118.                      (cons (finalize-quasiquote car-mode car-arg)
  119.                            cdr-arg)))
  120.             (else
  121.              (return 'cons*
  122.                      (list (finalize-quasiquote car-mode car-arg)
  123.                            (finalize-quasiquote cdr-mode cdr-arg))))))))
  124.  
  125. ;;;   #(a b c)     ==>  '#(a b c)
  126. ;;;   #(a ,b ,c)   ==>  (vector 'a b c)
  127. ;;;   #(a ,@b ,c)  ==>  (list->vector (append '(a) b (list c)))
  128. ;;; [To do: fix #(a ,b ,c)]
  129.  
  130. (define (descend-quasiquote-vector x level)
  131.   (receive (mode arg)
  132.            (descend-quasiquote (vector->list x) level)
  133.     (case mode
  134.       ((quote) (return 'quote x))
  135.       ((list)  (return 'vector arg))
  136.       (else    (return 'list->vector
  137.                        (list (finalize-quasiquote mode arg)))))))
  138.  
  139.  
  140.  
  141.  
  142.